home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / scmactst.scm < prev    next >
Text File  |  1999-04-19  |  4KB  |  161 lines
  1. ;;;"scmactst.scm" test syntactic closures macros
  2. ;;; From "sc-macro.doc", A Syntactic Closures Macro Facility by Chris Hanson
  3.  
  4. (define errs '())
  5. (define test
  6.   (lambda (expect fun . args)
  7.     (write (cons fun args))
  8.     (display "  ==> ")
  9.     ((lambda (res)
  10.        (write res)
  11.        (newline)
  12.        (cond ((not (equal? expect res))
  13.           (set! errs (cons (list res expect (cons fun args)) errs))
  14.           (display " BUT EXPECTED ")
  15.           (write expect)
  16.           (newline)
  17.           #f)
  18.          (else #t)))
  19.      (if (procedure? fun) (apply fun args) (car args)))))
  20.  
  21. (require 'syntactic-closures)
  22.  
  23. (macro:expand
  24.  '(define-syntax push
  25.     (syntax-rules ()
  26.           ((push item list)
  27.            (set! list (cons item list))))))
  28.  
  29. (test '(set! foo (cons bar foo)) 'push (macro:expand '(push bar foo)))
  30.  
  31. (macro:expand
  32.  '(define-syntax push1
  33.     (transformer
  34.      (lambda (exp env)
  35.        (let ((item
  36.           (make-syntactic-closure env '() (cadr exp)))
  37.          (list
  38.           (make-syntactic-closure env '() (caddr exp))))
  39.      `(set! ,list (cons ,item ,list)))))))
  40.  
  41. (test '(set! foo (cons bar foo)) 'push1 (macro:expand '(push1 bar foo)))
  42.  
  43. (macro:expand
  44.  '(define-syntax loop
  45.     (transformer
  46.      (lambda (exp env)
  47.        (let ((body (cdr exp)))
  48.      `(call-with-current-continuation
  49.        (lambda (exit)
  50.          (let f ()
  51.            ,@(map (lambda  (exp)
  52.             (make-syntactic-closure env '(exit)
  53.                         exp))
  54.               body)
  55.            (f)))))))))
  56.  
  57. (macro:expand
  58.  '(define-syntax let1
  59.     (transformer
  60.      (lambda (exp env)
  61.        (let ((id (cadr exp))
  62.          (init (caddr exp))
  63.          (exp (cadddr exp)))
  64.      `((lambda (,id)
  65.          ,(make-syntactic-closure env (list id) exp))
  66.        ,(make-syntactic-closure env '() init)))))))
  67.  
  68. (test 93 'let1 (macro:eval '(let1 a 90 (+ a 3))))
  69.  
  70. (macro:expand
  71.  '(define-syntax loop-until
  72.     (syntax-rules
  73.      ()
  74.      ((loop-until id init test return step)
  75.       (letrec ((loop
  76.         (lambda (id)
  77.           (if test return (loop step)))))
  78.     (loop init))))))
  79.  
  80. (test (macro:expand '(letrec ((loop (lambda (foo) (if #t 12 (loop 33)))))
  81.                (loop 3)))
  82.       'loop
  83.       (macro:expand '(loop-until foo 3 #t 12 33)))
  84.  
  85. (macro:expand
  86.  '(define-syntax loop-until1
  87.     (transformer
  88.      (lambda (exp env)
  89.        (let ((id (cadr exp))
  90.          (init (caddr exp))
  91.          (test (cadddr exp))
  92.          (return (cadddr (cdr exp)))
  93.          (step (cadddr (cddr exp)))
  94.          (close
  95.           (lambda (exp free)
  96.         (make-syntactic-closure env free exp))))
  97.      `(letrec ((loop
  98.             ,(capture-syntactic-environment
  99.               (lambda (env)
  100.             `(lambda (,id)
  101.                (,(make-syntactic-closure env '() `if)
  102.                 ,(close test (list id))
  103.                 ,(close return (list id))
  104.                 (,(make-syntactic-closure env '()
  105.                               `loop)
  106.                  ,(close step (list id)))))))))
  107.         (loop ,(close init '()))))))))
  108.  
  109. (test (macro:expand '(letrec ((loop (lambda (foo) (if #t 12 (loop 33)))))
  110.                   (loop 3)))
  111.       'loop1
  112.       (macro:expand '(loop-until1 foo 3 #t 12 33)))
  113.  
  114. (test '#t 'identifier (identifier? 'a))
  115. ;;; this needs to setup ENV.
  116. ;;;(test '#t 'identifier
  117. ;;;      (identifier? (macro:expand (make-syntactic-closure env '() 'a))))
  118. (test #f 'identifier (identifier? "a"))
  119. (test #f 'identifier (identifier? #\a))
  120. (test #f 'identifier (identifier? 97))
  121. (test #f 'identifier (identifier? #f))
  122. (test #f 'identifier (identifier? '(a)))
  123. (test #f 'identifier (identifier? '#(a)))
  124.  
  125. (test '(#t #f)
  126.       'syntax
  127.       (macro:eval
  128.        '(let-syntax
  129.         ((foo
  130.           (transformer
  131.            (lambda (form env)
  132.          (capture-syntactic-environment
  133.           (lambda (transformer-env)
  134.             (identifier=? transformer-env 'x env 'x)))))))
  135.       (list (foo)
  136.         (let ((x 3))
  137.           (foo))))))
  138.  
  139.  
  140. (test '(#f #t)
  141.       'syntax
  142.       (macro:eval
  143.        '(let-syntax ((bar foo))
  144.       (let-syntax
  145.           ((foo
  146.         (transformer
  147.          (lambda (form env)
  148.            (capture-syntactic-environment
  149.             (lambda (transformer-env)
  150.               (identifier=? transformer-env 'foo
  151.                     env (cadr form))))))))
  152.         (list (foo foo)
  153.           (foo bar))))))
  154.  
  155. (newline)
  156. (cond ((null? errs) (display "Passed all tests"))
  157.       (else (display "errors were:") (newline)
  158.         (display "(got expected (call))") (newline)
  159.         (for-each (lambda (l) (write l) (newline)) errs)))
  160. (newline)
  161.